home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / ASSEMBLE.S < prev    next >
Encoding:
Text File  |  1993-10-24  |  11.8 KB  |  446 lines
  1. ; ASSEMBLE.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*            The PCS Assembler                *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: David Bartley        Date: Oct 1985            *
  16. ;* Revision history:                            *
  17. ;* - 16 Mar 87: Added assembling of variable-length instructions    *
  18. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  19. ;*                                    *
  20. ;*                    ``In nomine omnipotentii dei''    *
  21. ;************************************************************************
  22.  
  23. ;   Input:
  24. ;
  25. ;    AL is a list of assembly language instructions and labels.
  26. ;
  27. ;   Output:
  28. ;
  29. ;    The output is a list of the following components:
  30. ;
  31. ;        (PCS-CODE-BLOCK num-constants
  32. ;                len-code
  33. ;                (constant ...)
  34. ;                (code-byte ...))
  35. ;
  36. ;    NUM-CONSTANTS is the number of constants.
  37. ;
  38. ;    The list of constants contains all constants and names of globals
  39. ;    and fluids which are referenced by the code.  They are indexed from
  40. ;    0 to 255 from left to right.
  41. ;
  42. ;    The code is represented as a series of integers in the range
  43. ;    -255 .. 255 of length LEN-CODE.
  44. ;
  45. ;
  46. ;   Pass 1:
  47. ;
  48. ;    determine the "worst case" size of each instruction
  49. ;
  50. ;    assign tentative locations to labels based on "worst case" sizes
  51. ;
  52. ;   Pass 2:
  53. ;
  54. ;    identify instructions which can use short-form addressing
  55. ;
  56. ;    assign "final" locations to labels
  57. ;
  58. ;   Pass 3:
  59. ;
  60. ;    extract constants from the instructions and collect them
  61. ;
  62. ;    translate the instruction stream into an encoded byte stream
  63. ;
  64. ;--------------------------------------------------------------------------
  65.  
  66. (define pcs-assembler
  67.   (lambda (al)
  68.     (letrec
  69.      (
  70. ;-----!
  71.  
  72.   (max-constants  255)     ; constants are indexed 0..255
  73.   (max-immediate  127)     ; largest signed immediate value
  74.   (min-immediate -128)     ; smallest signed immediate value
  75.   (max-delta-pc   127)     ; maximum jump displacement (short form)
  76.  
  77.   (labels      '())   ; ((label . locn) ...)
  78.   (constants      '())   ; (constant ...)
  79.   (code       '())   ; (codebyte ...)
  80.   (pc            0)     ; current simulated program counter
  81.  
  82.   (p1
  83.    (lambda (al)
  84.      (when al
  85.        (let ((x (car al)))
  86.          (if (or (atom? x)                ; label?
  87.              (number? (car x)))
  88.          (set! labels (cons (cons x pc) labels))
  89.          (set! pc (+ pc (span x pc))))
  90.          (p1 (cdr al))))))
  91.  
  92.   (p2
  93.    (lambda (al)
  94.      (when al
  95.        (let ((x (car al)))
  96.          (if (or (atom? x)                ; label?
  97.              (number? (car x)))
  98.          (let ((entry (assq x labels)))
  99.            (set-cdr! entry pc))
  100.          (set! pc (+ pc (span x pc))))
  101.          (p2 (cdr al))))))
  102.  
  103.   (p3
  104.    (lambda (al)
  105.      (when al
  106.        (let ((x (car al)))
  107.          (if (or (atom? x)                ; label?
  108.              (number? (car x)))
  109.          (let ((entry (assq x labels)))
  110.            (when (not (= pc (cdr entry)))
  111.              (writeln " *** ERROR in PCS-ASSEMBLER: " x)
  112.              (set! pc (cdr entry))))
  113.          (asm x))
  114.          (p3 (cdr al))))))
  115.  
  116.   (span
  117.    (lambda (x old-pc)
  118.      (let ((op (car x)))
  119.        (case op
  120.      (LOAD    (if (and (not (atom? (caddr x)))
  121.              (eq? (car (caddr x)) 'STACK)
  122.              (not (zero? (caddr (caddr x)))))
  123.             4 3))
  124.      (STORE (if (and (not (atom? (cadr x)))
  125.              (eq? (car (cadr x)) 'STACK)
  126.              (not (zero? (caddr (cadr x)))))
  127.             4 3))
  128.      (JUMP    (let ((long  (length x))
  129.               (entry (assoc (cadr x) labels)))
  130.           (if (null? entry)
  131.               long
  132.               (let* ((new-pc (+ old-pc long))
  133.                  (delta  (- (cdr entry) new-pc)))
  134.             (if (<= (abs delta) max-delta-pc)
  135.                 (begin
  136.                    (set-car! x 'HOP)  ; short jump
  137.                    (sub1 long))
  138.                 long)))))
  139.      (HOP    (length (cdr x)))
  140.      (CALL    (let ((kind (cadr x)))
  141.           (cond ((not (atom? kind))  5)
  142.             ((eq? kind 'EXIT)    1)
  143.             ((eq? (caddr x) 'CC) 2)
  144.             (else             3))))
  145.      (cons    4)
  146.      (CLOSE 5)
  147.      (LIVE    0)
  148.      ((%GRAPHICS %ESC %MOUSE)
  149.       (let ((length (cadr (caddr x))))    ; length is the number of optional arguments
  150.         (+ length 2)))                 ; !!! at least one (for return value) !!!
  151.      (else
  152.       (cond ((memq op '(PUSH POP DROP DROP-ENV PUSH-ENV UNBIND-FLUIDS))
  153.          2)
  154.         ((memq op '(car cdr caar cadr cdar cddr caaar caadr
  155.                 cadar caddr cdaar cdadr cddar cdddr cadddr
  156.                 %%car %%cdr BIND-FLUID))
  157.          3)
  158.         (else
  159.          (if (null? (cddr x))          ; no source operands
  160.              (if (getprop op 'pcs*nilargop)
  161.              1              ; no source or dest
  162.              2)               ; dest only
  163.              (length (cdr x)))))
  164.       )))))
  165.  
  166.   (asm
  167.    (lambda (x)
  168.      (let ((op (car x)))
  169.        (case op
  170.      (LOAD    (asm-load (reg (cadr x)) (caddr x)))
  171.      (STORE (asm-store (cadr x) (reg (caddr x))))
  172.      (JUMP    (asm-jump x))
  173.      (HOP    (asm-hop  x))
  174.      (CALL    (asm-call x))
  175.      (cons    (emit4 op (reg (cadr x))  (reg (caddr x)) (reg (cadddr x))))
  176.      (POP    (emit2 op (reg (cadr x))))
  177.      (PUSH    (emit2 op (reg (caddr x))))
  178.      (DROP    (emit2 op (car (cadr x))))
  179.      (DROP-ENV
  180.         (emit2 op (car (cadr x))))
  181.      (PUSH-ENV
  182.         (emit2 op (const (cadr x))))
  183.      (UNBIND-FLUIDS
  184.         (emit2 op (length (cadr x))))
  185.      (BIND-FLUID
  186.         (emit3 op (const (cadr x)) (reg (caddr x))))
  187.      ((%GRAPHICS %ESC %MOUSE)    ; format: (%graphics dest (quote len) r1 r2 ...)
  188.                     ; discard redundant 'dest' in (cadr x)
  189.       (emitv-regs op (cadr (caddr x)) (cdddr x)))
  190.      (CLOSE (let* ((label    (car (cadddr x)))
  191.                (target    (cdr (assoc label labels)))
  192.                (delta    (- target (+ pc 5)))
  193.                (dest    (reg (cadr x)))
  194.                (nargs    (cadr (cadddr x))))
  195.           (emit5 op dest (lo-byte delta) (hi-byte delta) nargs)))
  196.      (LIVE    '())
  197.      (else
  198.       (cond ((memq op '(%%car %%cdr car cdr caar cadr cdar
  199.                 cddr caaar caadr cadar caddr cdaar
  200.                 cdadr cddar cdddr cadddr))
  201.          (emit3 op (reg (cadr x)) (reg (caddr x))))
  202.         ((memq op '(%+imm %*imm %/imm))
  203.          (emit3 op (reg (caddr x)) (cadr (cadddr x))))
  204.         (else
  205.           (emit1 op)
  206.           (if (null? (cddr x))     ; no source operands
  207.               (if (getprop op 'pcs*nilargop)
  208.               '()                  ; no source or dest
  209.               (emit-regs (cdr x))) ; dest only
  210.               (emit-regs (cddr x)))))    ; discard redundant 'dest'
  211.       )))))
  212.  
  213.   (asm-load
  214.    (lambda (reg-dest src)
  215.      (if (number? src)
  216.      (emit3 'LOAD reg-dest (reg src))
  217.      (case (car src)
  218.        (quote  (let ((exp (cadr src)))
  219.              (if (and (integer? exp)
  220.                   (<= exp max-immediate)
  221.                   (>= exp min-immediate))
  222.              (emit3 'LOAD-IMMEDIATE
  223.                 reg-dest
  224.                 exp)
  225.              (emit3 'LOAD-CONSTANT
  226.                 reg-dest
  227.                 (const exp)))))
  228.        (STACK  (let ((offset (cadr src))
  229.              (delta-level (caddr src)))
  230.              (if (zero? delta-level)
  231.              (emit3 'LOAD-LOCAL
  232.                 reg-dest
  233.                 offset)
  234.              (emit4 'LOAD-LEX
  235.                 reg-dest
  236.                 offset
  237.                 delta-level))))
  238.        (HEAP   (emit3 'LOAD-ENV
  239.               reg-dest
  240.               (const (cadr src))))
  241.        (GLOBAL (emit3 'LOAD-GLOBAL
  242.               reg-dest
  243.               (const (cadr src))))
  244.        (FLUID  (emit3 'LOAD-FLUID
  245.               reg-dest
  246.               (const (cadr src))))))))
  247.  
  248.   (asm-store
  249.    (lambda (dest reg-src)
  250.      (case (car dest)
  251.        (STACK  (let ((offset (cadr dest))
  252.              (delta-level (caddr dest)))
  253.          (if (zero? delta-level)
  254.              (emit3 'STORE-LOCAL
  255.                 reg-src
  256.                 offset)
  257.              (emit4 'STORE-LEX
  258.                 reg-src
  259.                 offset
  260.                 delta-level))))
  261.        (HEAP   (emit3 'STORE-ENV
  262.               reg-src
  263.               (const (cadr dest))))
  264.        (GLOBAL (emit3 'STORE-GLOBAL
  265.               reg-src
  266.               (const (cadr dest))))
  267.        (GLOBAL-DEF
  268.            (emit3 'STORE-GLOBAL-DEF
  269.               reg-src
  270.               (const (cadr dest))))
  271.        (FLUID  (emit3 'STORE-FLUID
  272.               reg-src
  273.               (const (cadr dest)))))))
  274.  
  275.   (asm-jump
  276.    (lambda (x)
  277.      (let* ((target (cdr (assoc (cadr x) labels)))
  278.         (len    (length x))
  279.         (delta  (- target (+ pc len)))
  280.         (regs   (cdddr x)))
  281.        (emit1
  282.       (cdr (assq (caddr x)
  283.              '((ALWAYS . J_L)  (NULL?  . JN_L) (T?  . JNN_L)
  284.                (ATOM?  . JA_L) (NATOM? . JNA_L)(EQ? . JE_L)
  285.                (NEQ?   . JNE_L)))))
  286.        (emit-regs regs)
  287.        (emit-byte (lo-byte delta))
  288.        (emit-byte (hi-byte delta))
  289.        )))
  290.  
  291.   (asm-hop
  292.    (lambda (x)
  293.      (let* ((target (cdr (assoc (cadr x) labels)))
  294.         (len    (length (cdr x)))
  295.         (delta  (- target (+ pc len)))
  296.         (regs   (cdddr x)))
  297.        (emit1
  298.       (cdr (assq (caddr x)
  299.              '((ALWAYS . J_S)  (NULL?  . JN_S) (T?  . JNN_S)
  300.                (ATOM?  . JA_S) (NATOM? . JNA_S)(EQ? . JE_S)
  301.                (NEQ?   . JNE_S)))))
  302.        (emit-regs regs)
  303.        (emit-byte delta)
  304.        )))
  305.  
  306.   (asm-call
  307.    (lambda (x)
  308.      (let ((kind (cadr x)))
  309.        (cond ((not (atom? kind))
  310.           (let* ((target      (cdr (assoc (cadr kind) labels)))
  311.              (delta-level (caddr kind))
  312.              (delta-heap  (cadddr kind))
  313.              (delta      (- target (+ pc 5))))
  314.         (emit5 (cdr (assq (car kind)
  315.                   (if (and (cddr x)(eq? (caddr x) 'CC))
  316.                       '((OPEN . CCC) (OPEN-TR . CCC-TR))
  317.                       '((OPEN . CALL)(OPEN-TR . CALL-TR)))))
  318.                (lo-byte delta) (hi-byte delta)
  319.                delta-level     delta-heap))
  320.           )
  321.          (else
  322.           (case kind
  323.         (EXIT        (emit1 kind))
  324.         (CLOSED     (let ((fun-reg (reg (cadddr x))))
  325.                   (if (eq? (caddr x) 'CC)
  326.                   (emit2 'CCC-CLOSED fun-reg)
  327.                   (emit3 'CALL-CLOSURE
  328.                      fun-reg
  329.                      (car (caddr x)))))) ; nargs
  330.         (CLOSED-TR  (let ((fun-reg (reg (cadddr x))))
  331.                   (if (eq? (caddr x) 'CC)
  332.                   (emit2 'CCC-CLOSED-TR fun-reg)
  333.                   (emit3 'CALL-CLOSURE-TR
  334.                      fun-reg
  335.                      (car (caddr x)))))) ; nargs
  336.         (CLOSED-APPLY
  337.                 (emit3 'APPLY-CLOSURE
  338.                    (reg (caddr x))    ; funreg
  339.                    (reg (cadddr x)))) ; argreg
  340.         (CLOSED-APPLY-TR
  341.                 (emit3 'APPLY-CLOSURE-TR
  342.                    (reg (caddr x))    ; funreg
  343.                    (reg (cadddr x)))) ; argreg
  344.         ))))))
  345.  
  346.   (const
  347.    (lambda (exp)
  348.      (let ((entry (memv exp constants)))
  349.        (length (cdr (or entry
  350.             (begin
  351.               (set! constants (cons exp constants))
  352.               (if (> (length constants) max-constants)
  353.                   (error "Constants table overflow in compiler - Try (set! pcs-debug-mode '())")
  354.                   constants))))))))
  355.  
  356.   (reg
  357.    (lambda (index)
  358.      (* 4 index)))
  359.  
  360.   (hi-byte
  361.    (lambda (n)
  362.      (let ((hi (quotient (abs n) 256)))
  363.        (if (negative? n)
  364.        (if (zero? (remainder (abs n) 256))
  365.            (- 256 hi)
  366.            (- 255 hi))
  367.        hi))))
  368.  
  369.   (lo-byte
  370.    (lambda (n)
  371.      (let ((lo (remainder (abs n) 256)))
  372.        (if (negative? n)
  373.        (if (zero? lo)
  374.            lo
  375.            (- 256 lo))
  376.        lo))))
  377.  
  378.   (emit-byte
  379.    (lambda (byte)
  380.      (set! code (cons byte code))
  381.      (set! pc (add1 pc))))
  382.  
  383.   (emit-regs
  384.    (lambda (x)
  385.      (when x
  386.        (set! code (cons (reg (car x)) code))
  387.        (set! pc (add1 pc))
  388.        (emit-regs (cdr x)))))
  389.  
  390.   (emit-count
  391.    (lambda (len)
  392.      (set! code (cons len code))
  393.      (set! pc (add1 pc))))
  394.  
  395.   (emit1
  396.    (lambda (op)
  397.      (let ((opcode (if pcs-binary-output
  398.                (abs (or (getprop op 'pcs*opcode)
  399.                 (error "++ undefined opcode" op)))
  400.                op)))
  401.        (set! code (cons opcode code))
  402.        (set! pc (+ pc 1)))))
  403.  
  404.   (emit2
  405.    (lambda (op a)
  406.      (emit1 op)
  407.      (set! code (cons a code))
  408.      (set! pc (+ pc 1))))
  409.  
  410.   (emit3
  411.    (lambda (op a b)
  412.      (emit1 op)
  413.      (set! code (cons b (cons a code)))
  414.      (set! pc (+ pc 2))))
  415.  
  416.   (emit4
  417.    (lambda (op a b c)
  418.      (emit1 op)
  419.      (set! code (cons c (cons b (cons a code))))
  420.      (set! pc (+ pc 3))))
  421.  
  422.   (emit5
  423.    (lambda (op a b c d)
  424.      (emit1 op)
  425.      (set! code (cons d (cons c (cons b (cons a code)))))
  426.      (set! pc (+ pc 4))))
  427.  
  428.   (emitv-regs
  429.     (lambda (op len l)
  430.       (emit1 op)
  431.       (emit-count len)
  432.       (emit-regs l)))
  433.  
  434. ;-----!
  435.       )
  436.      (begin            ;; body of pcs-assembler
  437.     (p1 al)
  438.     (when labels
  439.           (set! pc 0)
  440.           (p2 al))
  441.     (set! pc 0)
  442.     (p3 al)
  443.     (set! constants (%reverse! constants))
  444.     (list 'PCS-CODE-BLOCK  (length constants)   pc
  445.           constants        (%reverse! code))))))
  446.